home *** CD-ROM | disk | FTP | other *** search
/ Ultra Pack / UltraComputing Partner Applications.iso / SunLabs / tclTK / src / tk4.0 / tests / color.test < prev    next >
Encoding:
Text File  |  1995-03-18  |  4.5 KB  |  168 lines
  1. # This file is a Tcl script to test out the procedures in the file
  2. # tkColor.c.  It is organized in the standard fashion for Tcl tests.
  3. #
  4. # Copyright (c) 1995 Sun Microsystems, Inc.
  5. #
  6. # See the file "license.terms" for information on usage and redistribution
  7. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  8. #
  9. # @(#) color.test 1.4 95/03/18 15:51:07
  10.  
  11. if {[info procs test] != "test"} {
  12.     source defs
  13. }
  14.  
  15. eval destroy [winfo children .]
  16. wm geometry . {}
  17. raise .
  18.  
  19. # cname --
  20. # Returns a proper name for a color, given its intensities.
  21. #
  22. # Arguments:
  23. # r, g, b -    Intensities on a 0-255 scale.
  24.  
  25. proc cname {r g b} {
  26.     format #%02x%02x%02x $r $g $b
  27. }
  28. proc cname4 {r g b} {
  29.     format #%04x%04x%04x $r $g $b
  30. }
  31.  
  32. # mkColors --
  33. # Creates a canvas and fills it with a 2-D array of squares, each of a
  34. # different color.
  35. #
  36. # Arguments:
  37. # c -        Name of canvas window to create.
  38. # width -    Number of squares in each row.
  39. # height -    Number of squares in each column.
  40. # r, g, b -    Initial value for red, green, and blue intensities.
  41. # rx, gx, bx -    Change in intensities between adjacent elements in row.
  42. # ry, gy, by -    Change in intensities between adjacent elements in column.
  43.  
  44. proc mkColors {c width height r g b rx gx bx ry gy by} {
  45.     catch {destroy $c}
  46.     canvas $c -width 400 -height 200 -bd 0
  47.     for {set y 0} {$y < $height} {incr y} {
  48.     for {set x 0} {$x < $width} {incr x} {
  49.         set color [format #%02x%02x%02x [expr $r + $y*$ry + $x*$rx] \
  50.             [expr $g + $y*$gy + $x*$gx] [expr $b + $y*$by + $x*$bx]]
  51.         $c create rectangle [expr 10*$x] [expr 20*$y] \
  52.             [expr 10*$x + 10] [expr 20*$y + 20] -outline {} \
  53.             -fill $color
  54.     }
  55.     }
  56. }
  57.  
  58. # closest -
  59. # Given intensities between 0 and 255, return the closest intensities
  60. # that the server can provide.
  61. #
  62. # Arguments:
  63. # w -        Window in which to lookup color
  64. # r, g, b -    Desired intensities, between 0 and 255.
  65.  
  66. proc closest {w r g b} {
  67.     set vals [winfo rgb $w [cname $r $g $b]]
  68.     list [expr [lindex $vals 0]/256] [expr [lindex $vals 1]/256] \
  69.         [expr [lindex $vals 2]/256]
  70. }
  71.  
  72. # c255  -
  73. # Given a list of red, green, and blue intensities, scale them
  74. # down to a 0-255 range.
  75. #
  76. # Arguments:
  77. # vals -    List of intensities.
  78.  
  79. proc c255 {vals} {
  80.     list [expr [lindex $vals 0]/256] [expr [lindex $vals 1]/256] \
  81.         [expr [lindex $vals 2]/256]
  82. }
  83.  
  84. # colorsFree --
  85. #
  86. # Returns 1 if there appear to be free colormap entries in a window,
  87. # 0 otherwise.
  88. #
  89. # Arguments:
  90. # w -            Name of window in which to check.
  91. # red, green, blue -    Intensities to use in a trial color allocation
  92. #            to see if there are colormap entries free.
  93.  
  94. proc colorsFree {w {red 31} {green 245} {blue 192}} {
  95.     set vals [winfo rgb $w [format #%02x%02x%02x $red $green $blue]]
  96.     expr ([lindex $vals 0]/256 == $red) && ([lindex $vals 1]/256 == $green) \
  97.         && ([lindex $vals 2]/256 == $blue)
  98. }
  99.  
  100. # Create a top-level with its own colormap (so we can test under
  101. # controlled conditions), then check to make sure that the visual
  102. # is color-mapped with 256 colors.  If not, just skip this whole
  103. # test file.
  104.  
  105. if [catch {toplevel .t -visual {pseudocolor 8} -colormap new}] {
  106.     return
  107. }
  108. wm geom .t +0+0
  109. if {[winfo depth .t] != 8} {
  110.     destroy .t
  111.     return
  112. }
  113. mkColors .t.c 40 6 0 0 0 0 6 0 0 0 40
  114. pack .t.c
  115. update
  116. if ![colorsFree .t.c 101 233 17] {
  117.     destroy .t
  118.     return
  119. }
  120. mkColors .t.c2 20 1 250 0 0 -10 0 0 0 0 0
  121. pack .t.c2
  122. if [colorsFree .t.c] {
  123.     destroy .t
  124.     return
  125. }
  126. destroy .t.c .t.c2
  127.  
  128. test color-1.1 {Tk_GetColor procedure} {
  129.     c255 [winfo rgb .t red]
  130. } {255 0 0}
  131. test color-1.2 {Tk_GetColor procedure} {
  132.     list [catch {winfo rgb .t noname} msg] $msg
  133. } {1 {unknown color name "noname"}}
  134.  
  135. test color-1.3 {Tk_GetColor procedure} {
  136.     c255 [winfo rgb .t #123456]
  137. } {18 52 86}
  138. test color-1.4 {Tk_GetColor procedure} {
  139.     list [catch {winfo rgb .t #xyz} msg] $msg
  140. } {1 {invalid color name "#xyz"}}
  141.  
  142. test color-2.1 {Tk_FreeColor procedure, reference counting} {
  143.     eval destroy [winfo child .t]
  144.     mkColors .t.c 40 6 0 240 240 0 -6 0 0 0 -40
  145.     pack .t.c
  146.     mkColors .t.c2 20 1 250 0 0 -10 0 0 0 0 0
  147.     pack .t.c2
  148.     update
  149.     set last [.t.c2 create rectangle 50 50 70 60 -outline {} \
  150.         -fill [cname 0 240 240]]
  151.     .t.c delete 1
  152.     set result [colorsFree .t]
  153.     .t.c2 delete $last
  154.     lappend result [colorsFree .t]
  155. } {0 1}
  156. test color-2.2 {Tk_FreeColor procedure, flushing stressed cmap information} {
  157.     eval destroy [winfo child .t]
  158.     mkColors .t.c 40 6 0 240 240 0 -6 0 0 0 -40
  159.     pack .t.c
  160.     mkColors .t.c2 20 1 250 0 0 -10 0 0 0 0 0
  161.     mkColors .t.c2 20 1 250 250 0 -10 -10 0 0 0 0
  162.     pack .t.c2
  163.     update
  164.     closest .t 241 241 1
  165. } {240 240 0}
  166.  
  167. destroy .t
  168.